perm filename FORM.SAI[GOD,HPM]1 blob
sn#423203 filedate 1979-03-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 BEGIN "FORM"
C00005 00003 INTEGER PROCEDURE SG(INTEGER A) RETURN((A LSH 19) ASH -19)
C00012 00004 STRING INDENT
C00016 00005 INTEGER FJ LIST FORM
C00021 ENDMK
C⊗;
BEGIN "FORM"
DEFINE MAXVAR=5000;
DEFINE NROOT=2, NLIST=4000;
REQUIRE "LIST.SAI[VIS,HPM]" SOURCE_FILE;
REQUIRE "GRAHDR.SAI[GRA,HPM]" SOURCE_FILE;
REQUIRE "FILHDR.SAI[VIS,HPM]" SOURCE_FILE;
STRING ARRAY VAR[0:MAXVAR];
INTEGER ARRAY FHD[0:'177,0:'203];
INTEGER NVAR,FOO;
DEFINE JTXT_=0,JDEP_=1,JLIN_=2;
DEFINE FNTHIG='201, FNTBAS='203;
INTEGER PROCEDURE FNTSELECT(INTEGER FNTNUM; STRING FILSPEC);
BEGIN "FNTSEL"
INTEGER ICHAN,FOO,IFLAG, I,X1,X2;
PRSFIL(""); PRSFIL("DSK:.FNT[XGP,SYS]");
PRSFIL(FILSPEC);
ICHAN←GETCHAN;
IFLAG←TRUE;
OPEN(ICHAN,DEVPRS,'10,2,0,FOO,FOO,IFLAG);
LOOKUP(ICHAN,FILPRS,IFLAG);
IF IFLAG THEN BEGIN RELEASE(ICHAN); RETURN(-1); END;
FNTSEL(FNTNUM,FILSPEC);
ARRYIN(ICHAN,FHD[FNTNUM,0],'204);
RELEASE(ICHAN);
FOR I←0 STEP 1 UNTIL '177 DO
IF FHD[FNTNUM,I]≠0 THEN
FHD[FNTNUM,I]←(FHD[FNTNUM,I] ASH -18)-1;
RETURN(FHD[FNTNUM,FNTHIG]); comment return height of font;
END "FNTSEL";
INTEGER PROCEDURE SG(INTEGER A); RETURN((A LSH 19) ASH -19);
INTEGER PROCEDURE US(INTEGER A); RETURN(A LAND '377777);
LIST PROCEDURE XYP(INTEGER X1,Y1,X2,Y2);
RETURN(CONS(CONS(US(X1),US(Y1)),CONS(US(X2),US(Y2))));
LIST PROCEDURE DEP(INTEGER X1,Y1,X2,Y2; LIST EXP);
RETURN(CONS(XYP(X1,Y1,X2,Y2),EXP));
LIST PROCEDURE SHA(INTEGER DX,DY; LIST EXP);
RETURN(CONS(CONS(US(DX),US(DY)),EXP));
LIST PROCEDURE LIN(INTEGER X1,Y1,X2,Y2,TH);
RETURN(DEP((X1 MIN X2)-TH,(Y1 MIN Y2)-TH,
(X1 MAX X2)+TH,(Y1 MAX Y2)+TH,
CONS(JLIN_,CONS(XYP(X1,Y1,X2,Y2),TH))));
PROCEDURE FET(LIST EXP; REFERENCE INTEGER X1,Y1,X2,Y2);
BEGIN X1←SG(CAAAR(EXP)); Y1←SG(CDAAR(EXP));
X2←SG(CADAR(EXP)); Y2←SG(CDDAR(EXP)); END;
LIST PROCEDURE JTXT(INTEGER F; STRING TXT);
BEGIN
INTEGER X1,Y1,X2,Y2; X1←X2←0;
Y1←(FHD[F,FNTBAS]-FHD[F,FNTHIG]);
Y2←(FHD[F,FNTBAS]-1);
VAR[NVAR←NVAR+1] ← TXT;
WHILE LENGTH(TXT)>0 DO
BEGIN INTEGER CH;
CH←LOP(TXT);
X1←X1 MIN (X2 + (FHD[F,CH] ASH -18) + 1);
X2←X2 MAX (X2 + ((FHD[F,CH] LSH 18) ASH -18) + 1);
END;
RETURN(DEP(X1,Y1,X2,Y2, CONS(JTXT_,CONS(F,NVAR))));
END;
LIST PROCEDURE JCAT(LIST A,B);
BEGIN INTEGER X1,Y1,X2,Y2, XA1,YA1,XA2,YA2, XSH;
FET(A,X1,Y1,X2,Y2); FET(B,XA1,YA1,XA2,YA2); XSH←X2-1;
RETURN(DEP(X1 MIN (XA1+XSH),Y1 MIN YA1,
X2 MAX (XA2+XSH),Y2 MAX YA2,
LIST3(JDEP_,SHA(0,0,A),SHA(XSH,0,B)))); END;
LIST PROCEDURE JSUB(LIST A,B);
BEGIN INTEGER X1,Y1,X2,Y2, XA1,YA1,XA2,YA2, XSH,YSH;
FET(A,X1,Y1,X2,Y2); FET(B,XA1,YA1,XA2,YA2);
XSH←X2+1; YSH←-(YA2-YA1+1)%2;
RETURN(DEP(X1 MIN (XA1+XSH),Y1 MIN (YA1+YSH),
X2 MAX (XA2+XSH),Y2 MAX (YA2+YSH),
LIST3(JDEP_,SHA(0,0,A),SHA(XSH,YSH,B)))); END;
LIST PROCEDURE JEXP(LIST A,B);
BEGIN INTEGER X1,Y1,X2,Y2, XA1,YA1,XA2,YA2, XSH,YSH;
FET(A,X1,Y1,X2,Y2); FET(B,XA1,YA1,XA2,YA2);
XSH←X2+1; YSH←Y2;
RETURN(DEP(X1 MIN (XA1+XSH),Y1 MIN (YA1+YSH),
X2 MAX (XA2+XSH),Y2 MAX (YA2+YSH),
LIST3(JDEP_,SHA(0,0,A),SHA(XSH,YSH,B))));
END;
LIST PROCEDURE JXBP(LIST A,B,C);
BEGIN INTEGER X1,Y1,X2,Y2, XA1,YA1,XA2,YA2,XB1,YB1,XB2,YB2, XSH,YSHA,YSHB;
FET(A,X1,Y1,X2,Y2); FET(B,XA1,YA1,XA2,YA2); FET(C,XB1,YB1,XB2,YB2);
XSH←X2+1; YSHA←-(YA2-YA1+1)%2; YSHB←Y2;
RETURN(DEP(X1 MIN (XA1+XSH) MIN (XB1+XSH),Y1 MIN (YA1+YSHA) MIN (YB1+YSHB),
X2 MAX (XA2+XSH) MAX (XB2+XSH),Y2 MAX (YA2+YSHA) MAX (YB2+YSHB),
LIST4(JDEP_,SHA(0,0,A),SHA(XSH,YSHA,B),SHA(XSH,YSHB,C))));
END;
LIST PROCEDURE PADD(INTEGER DX1,DY1,DX2,DY2; LIST A);
BEGIN INTEGER X1,Y1,X2,Y2;
FET(A,X1,Y1,X2,Y2);
RPLACA(CAAR(A),X1+DX1);
RPLACD(CAAR(A),Y1+DY1);
RPLACA(CDAR(A),X2+DX2);
RPLACD(CDAR(A),Y2+DY2);
RETURN(A);
END;
LIST PROCEDURE SHIF(INTEGER DX1,DY1; LIST A);
BEGIN INTEGER X1,Y1,X2,Y2;
FET(A,X1,Y1,X2,Y2);
RETURN(DEP(X1+DX1,Y1+DY1,X2+DX1,Y2+DY1,LIST2(JDEP_,SHA(DX1,DY1,A))));
END;
LIST PROCEDURE JUL(LIST A);
BEGIN INTEGER X1,Y1,X2,Y2; FET(A,X1,Y1,X2,Y2);
RETURN(DEP(X1,Y1-4,X2,Y2,LIST3(JDEP_,SHA(0,0,A),SHA(0,0,LIN(X1,Y1-1,X2,Y1-1,2)))));
END;
LIST PROCEDURE JSQR(LIST A);
BEGIN INTEGER X1,Y1,X2,Y2,XSH; FET(A,X1,Y1,X2,Y2);
XSH←(Y2-Y1+1)%4+15;
RETURN(DEP(X1,Y1,X2+XSH,Y2+4,LIST6(JDEP_,SHA(XSH,0,A),
SHA(0,0,LIN(X1+XSH,Y2+2,X2+XSH,Y2+2,2)),
SHA(0,0,LIN(X1+XSH,Y2+2,X1+15,Y1,2)),
SHA(0,0,LIN(X1+15,Y1,X1+5,Y1+10,2)),
SHA(0,0,LIN(X1+5,Y1+10,X1,Y1+7,2)) )));
END;
LIST PROCEDURE JDIV(LIST A,B);
BEGIN INTEGER X1,Y1,X2,Y2,XA1,YA1,XA2,YA2,XSH,XSHA,YSH,YSHA,XL,XR;
FET(A,X1,Y1,X2,Y2); FET(B,XA1,YA1,XA2,YA2);
XSH←(XA2-X2)%2; IF XSH<0 THEN BEGIN XSHA←-XSH; XSH←0; END;
YSH←2-Y1; YSHA←-2-YA2;
RETURN(DEP(XL←(X1+XSH) MIN (XA1+XSHA),
(Y1-YSH) MIN (YA1+YSHA),
XR←(X2+XSH) MAX (XA2+XSHA),
(Y2+YSH) MAX (YA2+YSHA),
LIST4(JDEP_,SHA(XSH,YSH,A),SHA(XSHA,YSHA,B),SHA(0,0,LIN(XL,0,XR,0,2)))));
END;
STRING INDENT;
RECURSIVE PROCEDURE SHOWSIT(LIST EXP);
BEGIN
INDENT←INDENT&" ";
IF NULLP(EXP) THEN RETURN ELSE
CASE CADR(EXP) OF BEGIN
[JTXT_] PRINT(INDENT,"(",CADDR(EXP)," ",VAR[CDDDR(EXP)],")",'15&'12);
[JDEP_] BEGIN LIST T; T←CDDR(EXP); WHILE ¬NULLP(T) DO
BEGIN PRINT(INDENT,"[",SG(CAAAR(T))," ",SG(CDAAR(T)),"]",'15&'12);
SHOWSIT(CDAR(T)); T←CDR(T); END; END;
[JLIN_] BEGIN LIST T; T←CDDR(EXP); PRINT(INDENT,"_____",'15&'12); END;
ELSE BEGIN PRINT("GARBLE "); PRLIST(EXP); PRINT('15&'12); END
END;
INDENT←INDENT[5 TO ∞];
END;
RECURSIVE PROCEDURE DEPOSIT(INTEGER X,Y; LIST EXP);
BEGIN
IF NULLP(EXP) THEN RETURN ELSE
CASE CADR(EXP) OF BEGIN
[JTXT_] FNTEXT(X,Y,CADDR(EXP),VAR[CDDDR(EXP)]);
[JDEP_] BEGIN LIST T; T←CDDR(EXP); WHILE ¬NULLP(T) DO
BEGIN DEPOSIT(X+SG(CAAAR(T)),Y+SG(CDAAR(T)),CDAR(T)); T←CDR(T); END; END;
[JLIN_] BEGIN LIST T; T←CDDR(EXP); FNTLIN(X+SG(CAAAR(T)),Y+SG(CDAAR(T)),
X+SG(CADAR(T)),Y+SG(CDDAR(T)),CDR(T)*0.99); END;
ELSE PRINT("GARBLE ",CADR(EXP),'15&'12)
END;
END;
PROCEDURE CENTER(REAL X,Y; LIST EXP);
BEGIN
INTEGER X1,Y1,X2,Y2;
FET(EXP,X1,Y1,X2,Y2);
DEPOSIT(X-(X1+X2)%2,Y,EXP);
END;
INTEGER FJ; LIST FORM;
LINIT; NVAR←1;
FJ←FILJOB("DSK:FORM.GFL[DOC,HPM]");
FNTSELECT(0,"GRFX25[1,RWG]"); comment graphics font for sqrt, boxes and drawings;
FNTSELECT(1,"NONM"); comment main text font;
FNTSELECT(2,"METMBM"); comment Math font;
FNTSELECT(3,"METSBM"); comment Small math font for sub-superscripts;
FNTSELECT(4,"GRKL51[1,RWG]"); comment Big greek, for π, sigma;
FNTSELECT(5,"GRKL30[1,RWG]"); comment Medium greek, for use with math font;
FNTSELECT(6,"BDR40"); comment Source of large bars, brackets, parens, R;
FNTSELECT(7,"PLUNK2[1,RWG]");
FNTSELECT(110,"METLB");
DDINIT; SCREEN(-1,-1,1,1); LINE(0,-1,0,1); LINE(-1,0,1,0);
LITEN;
FORM←NIL;
comment SETQ(FORM,JCAT(JTXT(2,"A "),JUL(JEXP(JTXT(1,"low"),JTXT(1,"high")))));
SETQ(FORM,
JCAT(
JCAT(JCAT(JSUB(JTXT(1,"Test"),JTXT(3,"subs")),JTXT(1," and ")),
JCAT(
JUL(JUL(JUL(JUL(JUL(JUL(JUL(JUL(JEXP(JTXT(1,"SUP"),JTXT(5,"scr"))))))))))
,JTXT(1," "))),
JCAT(JSQR(JDIV(
JXBP(JTXT(1,"A"),JTXT(3,"low"),JSUB(JTXT(3,"U"),JTXT(3,"b"))),
JTXT(2,"Denominator"))),JTXT(2," end") )));
FNTPOS(0,.2,1,1,0,0); CENTER(0,0,FORM);
FNTPOS(0,-.2,1,1,-.5,0); CENTER(0,0,FORM);
FNTPOS(.65,0,0,0,-1,1); CENTER(0,0,FORM);
FNTPOS(.85,0,SIN(.2),SIN(.2),-COS(.2),COS(.2)); CENTER(0,0,FORM);
BEGIN
STRING TXT; INTEGER L,I,J; REAL TH,X0,Y0,R,DX,TH1;
TXT←"Yow !!!! I am having FUN !!"; L←LENGTH(TXT);
X0←-.6; Y0←-.7; R←.3;
LITEN; ELLIPS(X0-R/3,Y0-R/3,X0+R/3,Y0+R/3);
FOR DX←-R/3,R/3 DO ELLIPS(X0+DX-2*R/9,Y0+R/9,X0+DX+2*R/9,Y0+5*R/9);
DRKEN;
FOR DX←-R/9,R/9 DO ELLIPS(X0+DX-R/12,Y0+R/9-R/12,X0+DX+R/9,Y0+R/9+R/12);
RECTAN(X0-R/9,Y0-2*R/9,X0+R/9,Y0-R/9);
LITEN;
FOR I←0 STEP 1 UNTIL L-1 DO
BEGIN
TH←3.1415926*(I-3)/(L-6);
TH1←3.1415926*(I-3+.5)/(L-6);
FNTPOS(X0-R*COS(TH),Y0+R*SIN(TH),SIN(TH1),SIN(TH1),-COS(TH1),COS(TH1));
FNTEXT(0,0,110,TXT[I+1 FOR 1]);
END;
X0←-.6; Y0←.7; R←.3;
LITEN; ELLIPS(X0-R/3,Y0-R/3,X0+R/3,Y0+R/3);
FOR DX←-R/3,R/3 DO ELLIPS(X0+DX-2*R/9,Y0-R/9,X0+DX+2*R/9,Y0-5*R/9);
DRKEN;
FOR DX←-R/9,R/9 DO ELLIPS(X0+DX-R/12,Y0-R/9+R/12,X0+DX+R/9,Y0-R/9-R/12);
RECTAN(X0-R/9,Y0+2*R/9,X0+R/9,Y0+R/9);
LITEN;
FOR I←0 STEP 1 UNTIL L-1 DO
BEGIN
TH←3.1415926*(I-3+L-6)/(L-6);
TH1←3.1415926*(I-3+.5+L-6)/(L-6);
FNTPOS(X0-R*COS(TH),Y0+R*SIN(TH),SIN(TH1),SIN(TH1),-COS(TH1),COS(TH1));
FNTEXT(0,0,110,TXT[I+1 FOR 1]);
END;
END;
DPYUP(-1);
KILJOB(FJ);
END "FORM";